home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
FishMarket 1.0
/
FishMarket v1.0.iso
/
fishies
/
051-075
/
disk_069
/
dk
/
dk.mod
< prev
Wrap
Text File
|
1992-05-06
|
12KB
|
415 lines
(*$Q*)
MODULE DK;
(* A little fun, inspired by Leo Schwab's TILT *)
(* Author: Thomas H. Handel, PeopleLink ID -- THH -- *)
(* I'm still learning Modula-2 and programming on Amy, so this may not
be the tidiest or best way to do what the program does. Also, it is
probably not the most elegant example of structured programming ever
created. Finally, I am certain that there are many enhancements that
more experienced programmers will be able to add (like maybe a close
gadget and the wherewithall to respond to it). Please fiddle at will.
If you have comments or suggestions, please contact me on PeopleLink or
by U.S. Snail at:
628 Harberts Ct.
Annapolis, MD 21401
Thanks in advance. *)
(* Placed in the Public Domain, 29 March 1987 *)
FROM SYSTEM IMPORT ADR, BYTE, NULL;
FROM Intuition IMPORT NewWindow, WindowPtr, IntuitionName, IntuitionBase,
WindowFlags, WindowFlagSet, IDCMPFlagSet,
CloseWindowFlag, ScreenFlagSet, WBenchScreen,
SmartRefresh,IntuiMessagePtr;
FROM Libraries IMPORT OpenLibrary, CloseLibrary;
FROM Windows IMPORT OpenWindow, CloseWindow;
FROM Strings IMPORT String;
FROM Pens IMPORT ReadPixel, WritePixel, SetAPen;
FROM GraphicsLibrary IMPORT GraphicsName, GraphicsBase;
FROM Ports IMPORT GetMsg, ReplyMsg, MessagePtr;
FROM Rasters IMPORT RastPortPtr;
FROM Storage IMPORT ALLOCATE, DEALLOCATE;
FROM RandomNumbers IMPORT Random;
VAR WPtr: WindowPtr;
NWin: NewWindow;
WNam: String;
RprtPtr: RastPortPtr;
MsgPtr : IntuiMessagePtr;
PROCEDURE Initialize(): BOOLEAN; (* Open the libraries *)
BEGIN
IntuitionBase := OpenLibrary(IntuitionName,0);
GraphicsBase := OpenLibrary(GraphicsName,0);
IF ((IntuitionBase = 0) OR (GraphicsBase = 0)) THEN RETURN FALSE
ELSE RETURN TRUE;
END;
END Initialize;
PROCEDURE InitWindow; (* Set up and open the window *)
BEGIN
WNam := "DK!";
WITH NWin DO
LeftEdge := 450;
TopEdge := 0;
Width := 100;
Height := 10;
DetailPen := BYTE(0);
BlockPen := BYTE(1);
IDCMPFlags := IDCMPFlagSet{CloseWindowFlag};
Flags := SmartRefresh + WindowFlagSet{Activate, WindowClose,
WindowDepth};
FirstGadget := NULL;
CheckMark := NULL;
Title := ADR(WNam);
Screen := NULL;
BitMap := NULL;
MinWidth := 0;
MinHeight := 0;
MaxWidth := 0;
MaxHeight := 0;
Type := ScreenFlagSet{WBenchScreen};
END;
WPtr := OpenWindow(NWin);
END InitWindow;
PROCEDURE Decay; (* Erode the display *)
TYPE ColNodePtr = POINTER TO ColNode;
ColNode = RECORD
Col : CARDINAL; (* X-value of column *)
Row : CARDINAL; (* Y-value of next non-zero pixel *)
PClr : CARDINAL; (* Pixel Pen number *)
Next : ColNodePtr; (* Forward pointer *)
Prev : ColNodePtr (* Backward pointer *)
END;
PixlNodePtr = POINTER TO PixlNode;
PixlNode = RECORD
PClr : CARDINAL; (* Pixel color *)
CurX : CARDINAL; (* Current location, X-value *)
CurY : CARDINAL; (* Current location, Y-value *)
Next : PixlNodePtr; (* Forward pointer *)
Prev : PixlNodePtr (* Backward pointer *)
END;
VAR ScrnTop : CARDINAL; (* Screen top *)
TopEdge : CARDINAL; (* Screen top less title bar *)
Bottom : CARDINAL; (* Screen bottom less border *)
YStrt : CARDINAL; (* Four pixels above bottom *)
ColCount : CARDINAL; (* Number of ColNodes in list *)
ColHead : ColNodePtr; (* Pointer to head of ColNode list *)
CPtr : ColNodePtr; (* Utility pointer for list traversal *)
PixlCount : CARDINAL; (* Number of PixlNodes in list *)
PixlHead : PixlNodePtr; (* Pointer to head of PixlNode list *)
PPtr : PixlNodePtr; (* Utility pointer for list traversal *)
Depth : ARRAY [2..637] OF CARDINAL; (* Depth of snow by col *)
PROCEDURE ComputeParms; (* Get some basic parameters *)
BEGIN
ScrnTop := WPtr^.WScreen^.TopEdge;
TopEdge := ScrnTop + 10;
Bottom := CARDINAL(WPtr^.WScreen^.Height) + ScrnTop - 1;
YStrt := Bottom - 4;
END ComputeParms;
PROCEDURE InitVars; (* Initialize Variables *)
VAR I : INTEGER; (* Counter *)
BEGIN
FOR I := 2 TO 637 DO
Depth[I] := 0
END;
RprtPtr := ADR(WPtr^.WScreen^.RPort);
ColCount := 0;
PixlCount := 0;
ColHead := NIL;
PixlHead := NIL
END InitVars;
PROCEDURE FindCols; (* Create list of cols containing non-zero pixls *)
VAR X : CARDINAL; (* Column Counter *)
Y : CARDINAL; (* Row Counter *)
Pixl : CARDINAL; (* Pen number of pixel *)
BEGIN
FOR X := 2 TO 637 DO
Y := YStrt;
LOOP
Pixl := ReadPixel(RprtPtr,X,Y);
IF Pixl <> 0 THEN
NEW (CPtr); (* Create node for list *)
CPtr^.Col := X;
CPtr^.Row := Y;
CPtr^.PClr := Pixl;
IF ColHead = NIL THEN (* and link it in at head of list *)
CPtr^.Next := NIL;
CPtr^.Prev := NIL
ELSE
CPtr^.Next := ColHead;
CPtr^.Prev := NIL;
ColHead^.Prev := CPtr
END;
ColHead := CPtr;
CPtr := NIL;
INC(ColCount);
EXIT
END;
Y := Y - 1;
IF Y <= TopEdge THEN
EXIT
END
END
END;
END FindCols;
PROCEDURE NewPixel; (* Get a new pixel at random for snowflake ops *)
VAR RNum : CARDINAL; (* Random Number *)
I : CARDINAL; (* Counter *)
Pixl : CARDINAL; (* Pen number of pixel *)
PROCEDURE DeleteCol; (* Remove an empty column from the list *)
BEGIN
IF CPtr = ColHead THEN
IF CPtr^.Next <> NIL THEN
ColHead := ColHead^.Next;
ColHead^.Prev := NIL
ELSE
ColHead := NIL
END
ELSE
IF CPtr^.Next = NIL THEN
CPtr^.Prev^.Next := NIL
ELSE
CPtr^.Prev^.Next := CPtr^.Next;
CPtr^.Next^.Prev := CPtr^.Prev
END
END;
DISPOSE (CPtr);
ColCount := ColCount - 1;
END DeleteCol;
BEGIN (* NewPixel *)
RNum := Random(ColCount - 1); (* 0 <= RNum <= [ColCount-1] *)
CPtr := ColHead;
IF RNum > 0 THEN
FOR I := 0 TO RNum DO
CPtr := CPtr^.Next
END
END;
NEW (PPtr);
PPtr^.PClr := CPtr^.PClr;
PPtr^.CurX := CPtr^.Col;
PPtr^.CurY := CPtr^.Row;
IF PixlHead = NIL THEN
PPtr^.Next := NIL;
PPtr^.Prev := NIL
ELSE
PPtr^.Next := PixlHead;
PPtr^.Prev := NIL;
PixlHead^.Prev := PPtr
END;
PixlHead := PPtr;
INC(PixlCount);
LOOP
CPtr^.Row := CPtr^.Row - 1;
IF CPtr^.Row < TopEdge THEN
DeleteCol;
EXIT
ELSE
Pixl := ReadPixel(RprtPtr,CPtr^.Col,CPtr^.Row);
IF Pixl <> 0 THEN
CPtr^.PClr := Pixl;
EXIT
END
END
END;
END NewPixel;
PROCEDURE MovePixels; (* Make the snow fall *)
VAR XDest : CARDINAL; (* Pixel destination, X-value *)
YDest : CARDINAL; (* Pixel destination, Y-value *)
DFlag : BOOLEAN; (* Signals pixel ready for deletion from list *)
RLFlag: BOOLEAN; (* Direction of snow drift *)
PROCEDURE DeletePixel; (* Remove a pixel from the list *)
VAR tPtr : PixlNodePtr; (* Utility pointer *)
BEGIN
tPtr := PPtr;
IF PPtr = PixlHead THEN
IF PPtr^.Next <> NIL THEN
PixlHead := PixlHead^.Next;
PixlHead^.Prev := NIL
ELSE
PixlHead := NIL
END;
tPtr := PPtr;
PPtr := PixlHead
ELSE
IF PPtr^.Next = NIL THEN
PPtr^.Prev^.Next := NIL
ELSE
PPtr^.Prev^.Next := PPtr^.Next;
PPtr^.Next^.Prev := PPtr^.Prev
END;
tPtr := PPtr;
PPtr := PPtr^.Prev
END;
DISPOSE (tPtr);
PixlCount := PixlCount - 1;
DFlag := FALSE;
END DeletePixel;
PROCEDURE ComputeDest; (* Compute a random destination for pixel *)
BEGIN
XDest := PPtr^.CurX + 8 - Random(16);
YDest := PPtr^.CurY + Random(13);
IF XDest <= 2 THEN
XDest := 3 + Random(5)
END;
IF XDest >= 637 THEN
XDest := 636 - Random(5)
END;
IF YDest > Bottom - Depth[XDest] THEN
YDest := Bottom - Depth[XDest];
DFlag := TRUE
END;
END ComputeDest;
PROCEDURE Drift; (* Keep the snow from stacking up in tall towers *)
VAR ChgFlag : BOOLEAN; (* Flags change in XDest *)
PROCEDURE CheckLeft; (* See if flake should drift left *)
BEGIN
IF Depth[XDest] > Depth[XDest-1] THEN
XDest := XDest - 1;
ChgFlag := TRUE
END
END CheckLeft;
PROCEDURE CheckRight; (* See if flake should drift right *)
BEGIN
IF Depth[XDest] > Depth[XDest+1] THEN
INC(XDest);
ChgFlag := TRUE
END
END CheckRight;
BEGIN (* Drift *)
ChgFlag := TRUE;
WHILE (XDest > 2) AND (XDest < 637) AND (ChgFlag) DO
ChgFlag := FALSE;
IF RLFlag THEN
CheckLeft;
CheckRight
ELSE
CheckRight;
CheckLeft
END;
YDest := Bottom - Depth[XDest] - 1
END
END Drift;
PROCEDURE MoveOne; (* Move one pixel to new destination *)
BEGIN
SetAPen(RprtPtr,0);
WritePixel(RprtPtr,PPtr^.CurX,PPtr^.CurY);
SetAPen(RprtPtr,PPtr^.PClr);
WritePixel(RprtPtr,XDest,YDest);
PPtr^.CurX := XDest;
PPtr^.CurY := YDest;
END MoveOne;
BEGIN (* MovePixels *)
RLFlag := TRUE;
DFlag := FALSE;
PPtr := PixlHead;
WHILE PPtr <> NIL DO (* While there are still flakes *)
ComputeDest; (* Find this one a new destination *)
IF DFlag THEN (* If it has landed *)
Drift; (* See if it should roll R or L *)
RLFlag := NOT(RLFlag)
END;
MoveOne; (* Actually move it to new dest *)
IF DFlag THEN (* If it has landed *)
INC(Depth[XDest]); (* increment depth in column *)
DeletePixel (* and remove pixel from list *)
END;
IF PPtr <> NIL THEN
PPtr := PPtr^.Next
END
END
END MovePixels;
PROCEDURE DanceOff; (* Clean things up *)
BEGIN
CloseWindow(WPtr);
CloseLibrary(IntuitionBase);
CloseLibrary(GraphicsBase);
END DanceOff;
BEGIN (* Decay *)
ComputeParms;
InitVars;
FindCols;
REPEAT
IF ColCount <> 0 THEN
NewPixel
END;
IF PixlCount <> 0 THEN
MovePixels
END;
MsgPtr := GetMsg(WPtr^.UserPort);
IF MsgPtr <> NULL THEN
ColCount := 0;
PixlCount := 0;
ReplyMsg (MessagePtr(MsgPtr));
END;
UNTIL (ColCount = 0) AND (PixlCount = 0);
DanceOff;
END Decay;
BEGIN (* DK *)
IF Initialize() THEN
InitWindow;
Decay;
END;
END DK.